home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / trans1.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  18.3 KB  |  596 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  9. ;;;       1001 TRANSLATE properties for everyone.                        ;;;
  10. ;;;       (c) Copyright 1980 Massachusetts Institute of Technology       ;;;
  11. ;;;       Maintained by GJC                                              ;;;
  12. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13.  
  14. (in-package "MAXIMA")
  15. ;;; This file handles System FSUBR translation properties that
  16. ;;; were not handled in TRANSL. 
  17.  
  18. (macsyma-module trans1)
  19.  
  20.  
  21. (TRANSL-MODULE TRANS1)
  22.  
  23. ;; Also defined in TRANSL;TRANSS
  24. #-CL (DEFVAR $TR_WINDY T)
  25.  
  26.  
  27. ;;;;;;;; THE FOLLOWING ARE MOSTLY FROM JPG MLISP ;;;;;;;;;;;;;;;;;;;;;
  28. ;;;
  29. ;;; MMAPEV DOES error checking and a macar of MEVAL down the arguments.
  30. ;;; The second arg to MMAPEV is purely for printing of error messages
  31. ;;; except for SCANMAP, which is obscure.
  32.  
  33. (comment
  34.  
  35. (DEFMFUN MMAPEV (MAPFUN L) 
  36.      (IF (< (LENGTH L) 2)
  37.          (MERROR "~:M called with fewer than 2 args" MAPFUN))
  38.      (LET ((U (GETOPR (MEVAL (CAR L)))))
  39.           (AUTOLDCHK U)
  40.           (BADFUNCHK (CAR L) U NIL)
  41.           (IF (ATOM U)
  42.           ;; number of argument checking before mapping,
  43.           ;; some efficiency gain, really, how minor.
  44.           ;; he should instead do some trampolining and
  45.           ;; get some real efficiency gains.
  46.           (MARGCHK U (COND ((EQ MAPFUN '$SCANMAP)
  47.                     (NCONS (CADR L)))
  48.                    (T (CDR L)))))
  49.           (CONS U (MAPCAR 'MEVAL (CDR L)))))
  50. )
  51.  
  52. (comment
  53.  (DEFMFUN $APPLY FEXPR (L)
  54.  (TWO-ARG-CHECK L)
  55.  ((LAMBDA (FUN ARG)
  56.    (COND ((NOT ($LISTP ARG))
  57.       (DISPLA FUN) (DISPLA ARG) (MERROR "Second arg to APPLY must be a list")))
  58.    (AUTOLDCHK (SETQ FUN (GETOPR FUN)))
  59.    (COND ((EQ (GET FUN 'DIMENSION) 'DIMENSION-INFIX) (TWOARGCHK ARG FUN)))
  60.    (MAPPLY FUN (CDR ARG) (CAR L)))
  61.   (MEVAL (CAR L)) (MEVAL (CADR L))))
  62. )
  63.  
  64. ;;; APPLY(F,[X]) is an idiom for funcall.
  65.  
  66. (DEFUN QUOTED-SYMBOLP (FORM)
  67.   (AND (EQ (ml-typep FORM) 'list)
  68.        (EQ 'QUOTE (CAR FORM))
  69.        (SYMBOLP (CADR FORM))))
  70.  
  71. (DEF%TR $APPLY (FORM)
  72.     (LET* ((FUN (DTRANSLATE (CADR FORM)))
  73.            (MODE (COND ((ATOM FUN)
  74.                 (FUNCTION-MODE-@ FUN))
  75.                ((QUOTED-SYMBOLP FUN)
  76.                 (FUNCTION-MODE (CADR FUN)))
  77.                ('ELSE
  78.                 '$ANY))))
  79.           (COND (($LISTP (CADDR FORM))
  80.              (LET ((ARGS (TR-ARGS (CDR (CADDR FORM)))))
  81.               (CALL-AND-SIMP MODE
  82.                      'MFUNCALL
  83.                      `(,FUN ,@ARGS))))
  84.             (T
  85.              (LET ((ARG (DTRANSLATE (CADDR FORM))))
  86.               (CALL-AND-SIMP MODE 'MAPPLY-TR
  87.                      `(,FUN ,ARG)))))))
  88.  
  89. ;;; (DEFMFUN $MAP FEXPR (L) (APPLY 'MAP1 (MMAPEV 'MAP L)))
  90.  
  91. (DEF%TR $MAP (FORM)
  92.     (LET (((FUN . ARGS) (TR-ARGS (CDR FORM))))
  93.          (CALL-AND-SIMP '$ANY 'MAP1 `((GETOPR ,FUN) . ,ARGS))))
  94.  
  95. ;;; (DEFMFUN $MAPLIST FEXPR (L) 
  96. ;;;  ((LAMBDA (MAPLP RES)
  97. ;;;   (SETQ RES (APPLY 'MAP1 (MMAPEV 'MAPLIST L)))
  98. ;;;   (COND ((ATOM RES) (LIST '(MLIST) RES))
  99. ;;;     ((EQ (CAAR RES) 'MLIST) RES)
  100. ;;;     (T (CONS '(MLIST) (CDR RES)))))
  101. ;;;    T NIL))
  102.  
  103. (DEF%TR $MAPLIST (FORM)
  104.   (LET (((FUN . ARGS) (TR-ARGS (CDR FORM))))
  105.     ;; this statement saves the trouble of adding autoload definitions
  106.     ;; for runtime translator support.
  107.     (PUSH-AUTOLOAD-DEF 'MARRAYREF '(MAPLIST_TR))
  108.     `($ANY . (MAPLIST_TR ,FUN ,@ARGS))))
  109.  
  110. ;;; (DEFMFUN $FULLMAP FEXPR (L)
  111. ;;;        (SETQ L (MMAPEV 'FULLMAP L)) (FMAP1 (CAR L) (CDR L) NIL))
  112.  
  113. (DEF%TR $FULLMAP (FORM)
  114.     (LET (((FUN . ARGS) (TR-ARGS (CDR FORM))))
  115.          (CALL-AND-SIMP '$ANY 'FMAP1 `((GETOPR ,FUN) (LIST . ,ARGS) NIL))))
  116.  
  117. ;;; (DEFMFUN $MATRIXMAP FEXPR (L)
  118. ;;;        ((LAMBDA (FMAPLVL) (APPLY 'FMAPL1 (MMAPEV 'MATRIXMAP L))) 2))
  119.  
  120. (DEF%TR $MATRIXMAP (FORM)
  121.     (LET (((FUN . ARGS) (TR-ARGS (CDR FORM))))
  122.          (CALL-AND-SIMP '$ANY `(LAMBDA (FMAPLVL)
  123.                        (FMAPL1 (GETOPR ,FUN) . ,ARGS))
  124.                 '(2))))
  125.                
  126. ;;; (DEFMFUN $FULLMAPL FEXPR (L) (APPLY 'FMAPL1 (MMAPEV 'FULLMAPL L)))
  127.  
  128. (DEF%TR $FULLMAPL (FORM)
  129.     (LET (((FUN . ARGS) (TR-ARGS (CDR FORM))))
  130.          (CALL-AND-SIMP '$ANY 'FMAPL1 `((GETOPR ,FUN) . ,ARGS))))
  131.  
  132. ;;;(DEFMFUN $OUTERMAP FEXPR (L)
  133. ;;; (APPLY (COND ((= (LENGTH L) 2) 'FMAPL1) (T 'OUTERMAP1)) (MMAPEV 'OUTERMAP L)))
  134.  
  135. (DEF%TR $OUTERMAP (FORM)
  136.     (LET (((FUN . ARGS) (TR-ARGS (CDR FORM))))
  137.          (CALL-AND-SIMP '$ANY (COND ((= (LENGTH ARGS) 1) 'FMAPL1)
  138.                     (T 'OUTERMAP1))
  139.                 `((GETOPR ,FUN)  ,@ARGS))))
  140.  
  141.  
  142. ;;;(DEFMFUN $SCANMAP FEXPR (L)
  143. ;;; (LET ((SCANMAPP T)) (SSIMPLIFYA (APPLY 'SCANMAP1 (MMAPEV '$SCANMAP L)))))
  144.  
  145. (DEF%TR $SCANMAP (FORM)
  146.     (PUSH-AUTOLOAD-DEF '$SCANMAP '(SCANMAP1))
  147.     ;; there's something more fundamental about the above than
  148.     ;; just autoload definitions.
  149.     (LET (((FUN . ARGS) (TR-ARGS (CDR FORM))))
  150.          (CALL-AND-SIMP '$ANY 'SCANMAP1 `((GETOPR ,FUN) ,@ARGS))))
  151.  
  152. ;;;(DEFMFUN $QPUT FEXPR (L)
  153. ;;; (COND ((NOT (= (LENGTH L) 3)) (ERLIST '|Wrong number of args to QPUT|)))
  154. ;;; ($PUT (CAR L) (CADR L) (CADDR L)))
  155.  
  156. (DEF%TR $QPUT (FORM)
  157.     `($ANY $PUT ',(CADR FORM) ',(CADDR FORM) ',(CADDDR FORM)))
  158.  
  159. ;;;(DEFMFUN $SUBVAR FEXPR (L)
  160. ;;; (COND ((NULL L) (ERLIST "Wrong number of args to SUBVAR")))
  161. ;;; (MEVAL (CONS '(MQAPPLY ARRAY) L)))
  162.  
  163. (DEF%TR $SUBVAR (FORM)
  164.     (TRANSLATE (CONS '(MQAPPLY ARRAY) (CDR FORM))))
  165.  
  166. ;;; From JPG;COMM >
  167. ;;;(DEFMFUN $PART N (PART1 (LISTIFY N) NIL NIL $INFLAG))
  168. ;;;
  169. ;;;(DEFMFUN $INPART N (PART1 (LISTIFY N) NIL NIL T))
  170. ;;;
  171. ;;;(DEFMFUN $SUBSTPART FEXPR (L) (PART1 L T NIL $INFLAG))
  172. ;;;
  173. ;;;(DEFMFUN $SUBSTINPART FEXPR (L) (PART1 L T NIL T))
  174. ;;;
  175. ;;;(DEFUN PART1 (ARGLIST SUBSTFLAG DISPFLAG INFLAG) ....)
  176.  
  177. ;;; If the evaluation of the first argument does not depend on the
  178. ;;; setting of the special variable PIECE, then it need not be 
  179. ;;; evaluated inside of PART1. If the PIECE feature is used, then
  180. ;;; we must send down an expression to PART1 which when evaluated has
  181. ;;; the proper environment for the compiled-away variable names in the
  182. ;;; environment of the calling function. 
  183. ;;; It is possible to get unbelivebly strange results from the order of
  184. ;;; evaluation of the arguments to $SUBSTPART, these crocks shall not
  185. ;;; be supported.
  186. ;;; The PIECE feature is not as often used as say,
  187. ;;; SUBSTPART("*",EXP,0) is.
  188.  
  189. (DEF%TR $SUBSTPART (FORM)
  190.     (SUBSTPART-TRANSLATION FORM T NIL '$INFLAG))
  191.  
  192. (DEF%TR $SUBSTINPART (FORM)
  193.     (SUBSTPART-TRANSLATION FORM T NIL T))
  194.  
  195. (DEFUN FOR-EVAL-THEN-MQUOTE-SIMP-ARGL (L)
  196. ;       (MAPCAR #'(LAMBDA (U) ;;; consing not important here.
  197. ;             `(LIST '(MQUOTE SIMP) ,U))
  198. ;           L)
  199. ; JONL broke the fucking compiler. So I re-write this as=>
  200.        (PROG (V)
  201.          LOOP
  202.          (IF (NULL L) (RETURN (NREVERSE V)))
  203.          (PUSH `(LIST '(MQUOTE SIMP) ,(POP L)) V)
  204.          (GO LOOP)))
  205.  
  206. (DEFUN  SUBSTPART-TRANSLATION (FORM FLAG1 FLAG2 FLAG3)
  207.     (LET* ((SUBST-ITEM (DTRANSLATE (CADR FORM)))
  208.            (FREEVARS (FREE-LISP-VARS SUBST-ITEM))
  209.            (ARGL (TR-ARGS (CDDR FORM))))
  210.           (COND ((NULL (ASSQ '$PIECE FREEVARS))
  211.              ; this code is just to screw the people who
  212.              ; would use $PIECE non lexicaly. Not really, the
  213.                      ; closure hacking is a lot slower at run time than
  214.              ; this easy case, so no sense screwing the people who
  215.              ; don't use $PIECE in foolish ways.
  216.              `($ANY . (SIMPLIFY
  217.                    (PART1
  218.                 (LIST  ,@(FOR-EVAL-THEN-MQUOTE-SIMP-ARGL
  219.                       (CONS SUBST-ITEM ARGL)))
  220.  
  221.                    ,FLAG1 ,FLAG2 ,FLAG3))))
  222.             (T
  223.              (SETQ FREEVARS (TBOUND-FREE-VARS FREEVARS))
  224.              (SIDE-EFFECT-FREE-CHECK (CADR FREEVARS) (CADR FORM))
  225.              `($ANY . (SIMPLIFY
  226.                    (PART1 (LIST (FUNGEN&ENV-FOR-MEVAL
  227.                          ,(zl-DELETE '$PIECE (CAR FREEVARS))
  228.                          ($PIECE) ,SUBST-ITEM)
  229.                         ,@(FOR-EVAL-THEN-MQUOTE-SIMP-ARGL ARGL))
  230.                       ,FLAG1 ,FLAG2 ,FLAG3)))))))
  231.  
  232.  
  233.  
  234.  
  235. ;;; From JPG;SUPRV >
  236. (comment
  237. (DEFMFUN $ERRCATCH FEXPR (X)
  238.        ((LAMBDA (ERRCATCH RET)
  239.         (COND ((NULL (SETQ RET
  240.                    (ERRSET (APPLY 'MPROGN X)
  241.                        LISPERRPRINT)))
  242.                (ERRLFUN1 ERRCATCH)))
  243.         (CONS '(MLIST) RET))
  244.     (CONS BINDLIST LOCLIST) NIL)))
  245.  
  246. ;;; This is could be done better on the LISPM
  247.  
  248. (DEF%TR $ERRCATCH (FORM)
  249.     (SETQ FORM (TRANSLATE `((MPROGN) ,@(CDR FORM))))
  250.     `(,(CAR FORM) . ((LAMBDA (ERRCATCH RET) ;;; ERRCATCH SPECIAL IN TINCLU >
  251.                  (COND ((NULL (SETQ RET
  252.                             (ERRSET ,(CDR FORM)
  253.                                 LISPERRPRINT)))
  254.                     (ERRLFUN1 ERRCATCH)))
  255.                  (CONS '(MLIST) RET))
  256.              (CONS BINDLIST LOCLIST) NIL)))
  257.  
  258.  
  259. (COMMENT 
  260.  (DEFMFUN $CATCH FEXPR (X)
  261.     ((LAMBDA (MCATCH)
  262.          (PROG2 NIL (CATCH 'MCATCH (APPLY 'MPROGN X))
  263.             (ERRLFUN1 MCATCH)))
  264.   (CONS BINDLIST LOCLIST))))
  265.  
  266. ;;; The MODE of a CATCH could either be the MODE of the last of the PROGN
  267. ;;; or the mode of the THROW. The THROW may be hard to find, so this goes
  268. ;;; on the assumption that the mode of the PROGN is enough to tell.
  269.  
  270. (DEF%TR $CATCH (FORM)
  271.     (LET (((MODE . BODY) (TRANSLATE `((MPROGN) . ,(CDR FORM)))))
  272.          `(,MODE . ((LAMBDA ()
  273.                 ((LAMBDA (MCATCH)
  274.                      (PROG2 NIL
  275.                         (CATCH
  276.                          'MCATCH ,BODY)
  277.                         (ERRLFUN1 MCATCH)))
  278.                  (CONS BINDLIST LOCLIST)))))))
  279. (COMMENT
  280.  (DEFMFUN $THROW (X)
  281.  (COND ((NULL MCATCH) (DISPLA X) (ERLIST '|THROW not within CATCH|)))
  282.  (THROW 'MCATCH X)))
  283.  
  284. (DEF%TR $THROW (FORM)
  285.     (LET (((MODE . EXP) (TRANSLATE (CADR FORM))))
  286.          `(,MODE . ((LAMBDA (X)
  287.                 (COND ((NULL MCATCH)
  288.                        (DISPLA X)
  289.                        (*MERROR '|THROW not within CATCH|)))
  290.                 (THROW 'MCATCH X))
  291.             ,EXP))))
  292.  
  293. ;;; From RZ;ASUM >. He should know better.
  294. (comment 
  295.  (DEFMFUN $sum fexpr (l)
  296.     (cond ((not (= (length l) 4))
  297.        (erlist '|Wrong no. of args to SUM|))
  298.       ((dosum (car l) (cadr l) (meval (caddr l)) (meval (cadddr l)) t)
  299.        ))))
  300.  
  301. ;;; From RZ;COMBIN >
  302. (comment
  303.  (DEFMFUN $product fexpr (l)
  304.     (cond ((not (= (length l) 4)) (erlist '|Wrong no. of args to product|))
  305.       ((dosum (car l) (cadr l)   (meval (caddr l)) (meval (cadddr l)) nil)))))
  306. ;;; "dosum" will call MEVAL and act like a special form if it can.
  307. ;;; MEVAL will work on LISP expression, so we can translate those args.
  308.  
  309. (DEFUN START-VAL (SUMP MODE)
  310.        (CASE MODE
  311.           (($FLOAT)
  312.            (IF SUMP 0.0 1.0))
  313.           (T
  314.            (IF SUMP 0 1))))
  315.  
  316. (DEF%TR $SUM (FORM)
  317.     (LET (((|0| N) (MAPCAR #'TRANSLATE (CDDDR FORM)))
  318.           (FLAG (EQ (CAAR FORM) '$SUM))
  319.           (VAR (CADDR FORM))
  320.           (SUM (tr-GENSYM)))
  321.          (COND ((AND (EQ (CAR |0|) '$FIXNUM)
  322.              (EQ (CAR N) '$FIXNUM))
  323.             (LET ((SUM-EXP
  324.                (TR-LOCAL-EXP `((,(COND (FLAG 'MPLUS)
  325.                            (T 'MTIMES)))
  326.                        ,SUM ,(CADR FORM))
  327.                      SUM '$FIXNUM
  328.                      VAR '$FIXNUM))
  329.               (|00| (tr-gensym))
  330.               (NN (tr-gensym)))
  331.              ;; here is the bummer. We need to know the
  332.              ;; mode of SUM before we know the mode of the
  333.              ;; SUM-EXP, but that tells us something about
  334.              ;; the mode of the SUM.
  335.              ;; When the mode is float we really need to know
  336.              ;; because of the initialization of the SUM, which
  337.              ;; must be correct if COMPLR is to win on things
  338.              ;; like (*$ (DO ...) ...)
  339.              (IF (EQ (CAR SUM-EXP) '$FLOAT)
  340.                  (SETQ SUM-EXP
  341.                    (TR-LOCAL-EXP
  342.                     `((,(COND (FLAG 'MPLUS)
  343.                           (T 'MTIMES)))
  344.                       ,SUM ,(CADR FORM))
  345.                     SUM '$FLOAT
  346.                     VAR '$FIXNUM)))
  347.              ;; hey if this changes Modes on us, forget it man,
  348.              ;; geezz. lets not bother checking, and just
  349.              ;; catch this bad-boy in the COMPLR.
  350.              ;; What do we say to the user anyway about such
  351.              ;; crazzyness?
  352.  
  353.              `(,(CAR SUM-EXP)
  354.                . ((LAMBDA (,|00| ,NN)
  355.                       (COND ((NOT (< ,NN ,|00|))
  356.                          (DO ((,VAR ,|00| (f1+ ,VAR))
  357.                           (,SUM ,(START-VAL
  358.                               FLAG
  359.                               (CAR SUM-EXP))
  360.                             ,(CDR SUM-EXP)))
  361.                          ((< ,NN ,VAR) ,SUM)
  362.                          ))
  363.                         ((= ,NN (f1- ,|00|))
  364.                          ,(START-VAL FLAG (CAR SUM-EXP)))
  365.                         (T
  366.                          (INTERVAL-ERROR ',(caar form) ,|00| ,NN))))
  367.                   ,(CDR |0|)
  368.                   ,(CDR N)))))
  369.            (T
  370.             (LET* ((SUMARG (CDR (TR-LOCAL-EXP (CADR FORM) (CADDR FORM)
  371.                               '$ANY)))
  372.                (VAR (CADDR FORM))
  373.                (FREE-VAR-INFO (TBOUND-FREE-VARS (FREE-LISP-VARS SUMARG))))
  374.               (SIDE-EFFECT-FREE-CHECK (CADR FREE-VAR-INFO)
  375.                           (CADR FORM))
  376.               `($ANY . (DOSUM (FUNGEN&ENV-FOR-MEVALSUMARG
  377.                        ,(zl-DELETE VAR (CAR FREE-VAR-INFO))
  378.                        (,VAR)
  379.                        ,SUMARG
  380.                        ;; the original form is here for when we
  381.                        ;; get mevalsumarged, otherwise we use
  382.                        ;; the translated SUMARG when we get
  383.                        ;; MEVAL'ed.
  384.                        ,(CADR FORM))
  385.                       ',VAR ,(CDR |0|) ,(CDR N) ,FLAG)))))))
  386.  
  387.  
  388. (DEF%TR-INHERIT $SUM $PRODUCT)
  389.  
  390.  
  391.  
  392. ;;; Makelist is a very sorry FSUBR. All these FSUBRS are just to avoid
  393. ;;; writing LAMBDA. But lots of users use MAKELIST now. 
  394. ;;; MAKELIST(EXP,X,0,N) with 4 args it is an iteration, with three it
  395. ;;; is a mapping over a list (the third argument).
  396.  
  397. (DEF%TR $MAKELIST (FORM)
  398.     (SETQ FORM (CDR FORM))
  399.     (COND ((= (LENGTH FORM) 3)
  400.            (LET  (((EXP X LLIST) FORM)
  401.               (SUM (tr-GENSYM))
  402.               (LIL (tr-GENSYM)))
  403.              `($ANY . (DO ((,LIL (CDR ,(DTRANSLATE LLIST)) (CDR ,LIL))
  404.                    (,SUM NIL)
  405.                    (,X))
  406.                   ((NULL ,LIL)
  407.                    `((MLIST) ,@(NREVERSE ,SUM)))
  408.                   (SETQ ,X (CAR ,LIL)
  409.                     ,SUM (CONS ,(CDR (TR-LOCAL-EXP EXP
  410.                                        X
  411.                                        (VALUE-MODE X)))
  412.                            ,SUM))))))
  413.           ((= (LENGTH FORM) 4)
  414.            (LET (((EXP X |0| N) FORM)
  415.              (|00| (tr-GENSYM))
  416.              (NN (tr-GENSYM))
  417.              (SUM (tr-GENSYM)))
  418.             (SETQ |0| (DTRANSLATE |0|) ; I had forgotten this before!
  419.               N (DTRANSLATE N))  ; never noticed.
  420.             `($ANY . ((LAMBDA (,|00| ,NN)
  421.                       ; bogus -gjc
  422.                       ;(DECLARE (FIXNUM ,|00| ,NN))
  423.                       (COND ((NOT (< ,NN ,|00|))
  424.                          (DO ((,X ,|00| (f1+ ,X))
  425.                           (,SUM
  426.                            NIL
  427.                            (CONS
  428.                             ,(CDR (TR-LOCAL-EXP EXP
  429.                                     X
  430.                                     '$FIXNUM))
  431.  
  432.                             ,SUM)))
  433.                          ((> ,X ,NN)
  434.                           `((MLIST) ,@(NREVERSE ,SUM)))
  435.                          (DECLARE (FIXNUM ,X))))
  436.                          (T
  437.                           (INTERVAL-ERROR
  438.                            '$MAKELIST ,|00| ,NN))))
  439.                   ,|0| ,N))))
  440.           (T
  441.            (MFORMAT *TRANSLATION-MSGS-FILES*
  442.             "Wrong number of args to MAKELIST")
  443.            (SETQ TR-ABORT T)
  444.            '($ANY . '$**ERROR**))))
  445.  
  446. (comment
  447.  |jpg;suprv >|
  448.  (DEFMFUN $KILL FEXPR (L) (MAPC 'KILL1 L) #+GC (GCTWA) '$DONE))
  449.  
  450. (DEF%TR $KILL (FORM)
  451.     (COND ($TR_WINDY
  452.            (TR-TELL "
  453. Warning:" FORM
  454. "Use of KILL in translated program is not recommended. See GJC for
  455. a replacement form. Translating anyway though.")))
  456.     `($ANY . (APPLY '$KILL ',(CDR FORM))))
  457.  
  458. ;;; Macsyma arrays are the biggest crock since STATUS PUNT NIL days.
  459. ;;; The basic idea of ARRAY(<frob>,type,dims...) is that
  460. ;;; if type is of
  461. ;;;(ASSQ (CADR X) '(($COMPLETE . T) ($INTEGER . FIXNUM) ($FIXNUM . FIXNUM)
  462. ;;;              ($FLOAT . FLONUM) ($FLONUM . FLONUM)))
  463. ;;; then the dims are evaluated. But, if type is not one of those,
  464. ;;; it "must" be a dim spec! Of course, I must make this "analysis"
  465. ;;; at translate time, in order to preserve referential transparency
  466. ;;; in compiled code.
  467.  
  468. (DEF%TR $ARRAY (FORM)
  469.     (SETQ FORM (CDR FORM))
  470.     (LET ((NAME (CAR FORM))
  471.           (SPECP (ASSQ (CADR FORM)
  472.                '(($COMPLETE . T) ($INTEGER . FIXNUM) ($FIXNUM . FIXNUM)
  473.                          ($FLOAT . FLONUM) ($FLONUM . FLONUM)))))
  474.          (COND (SPECP
  475.             `($ANY . (APPLY '$ARRAY (LIST ',NAME
  476.                           ',(CADR FORM)
  477.                           ,@(TR-ARGS (CDDR FORM))))))
  478.            (T
  479.             `($ANY . (APPLY '$ARRAY (LIST ',NAME
  480.                           ,@(TR-ARGS (CDR FORM)))))))))
  481.  
  482.  
  483. (comment
  484. (DEFMFUN $DEFINE FEXPR (L)
  485.  (COND ((OR (NULL L) (NULL (CDR L)) (CDDR L))
  486.     (ERLIST '|Wrong number of args to DEFINE|)))
  487.  (APPLY 'MDEFINE
  488.     (LIST (COND ((MQUOTEP (CAR L)) (CADAR L)) (T (DISP2 (CAR L)))) (MEVAL (CADR L))))))
  489.  
  490. ;;; MDEFINE is an FSUBR also.
  491.  
  492. (DEF%TR $DEFINE (FORM)
  493.     (LET (((HEADER BODY) (CDR FORM)))
  494.          `($ANY . (APPLY 'MDEFINE
  495.                  (LIST ',(COND ((MQUOTEP HEADER) (CADR HEADER))
  496.                        (T (DISP2 HEADER)))
  497.                    ,(DTRANSLATE BODY))))))
  498.  
  499.  
  500. ;;; it seems TRANSL has all sorts of code for hacking some kind of
  501. ;;; $CRE mode. somehow there is no translate property for MRAT. who
  502. ;;; knows. anyway here is something in the mean time before this
  503. ;;; I have time to do up TRANSL correctly.
  504. ;;;(DEFUN MRATEVAL (X)
  505. ;;; ((LAMBDA (VARLIST)
  506. ;;;   (COND (EVP (MEVAL ($RATDISREP X)))
  507. ;;;     ((OR (AND $FLOAT $KEEPFLOAT) (NOT (ALIKE VARLIST (MAPCAR 'MEVAL VARLIST))))
  508. ;;;      (RATF (MEVAL ($RATDISREP X))))
  509. ;;;     (T X)))
  510. ;;;  (CADDAR X)))
  511. ;;; EVP is a hack for $EV I think. The MEVAL down the varlist is to see if the
  512. ;;; variables have any values, if not, then the result of (ratf (meval ($ratdisrep)))
  513. ;;; will be alike to what you started with, so it is an efficiency hack! What a
  514. ;;; joke!
  515. ;;;(DEFPROP MRAT (LAMBDA (X) (MRATEVAL X)) MFEXPR*)
  516.  
  517. (def%tr mrat (form)
  518.     (let ((t-form (translate ($ratdisrep form))))
  519.          (cond ((memq (car t-form) '($float $fixnum $number)) t-form)
  520.            (t `($ANY . (RATF ,(CDR T-FORM)))))))
  521.  
  522.  
  523. ;;; The following special forms do not call the evaluator.
  524.  
  525.  
  526.  
  527.  
  528.  
  529.  
  530.  
  531. (DEF%TR $batcon (FORM)
  532.   `($ANY . (MEVAL ',FORM)))  
  533. ;;most of these will lose in common since a local variable will not
  534. ;;have its value accessible to the mfexpr*.  They should
  535. ;;be redone as macros with any necessary info passed along.
  536.  
  537. (DEF%TR $REMARRAY           $batcon)
  538. (DEF%TR $REARRAY $batcon)
  539. (DEF%TR $ALIAS $batcon)
  540. (DEF%TR $ALLOC $batcon)
  541. (DEF%TR $BATCH $batcon)
  542. (DEF%TR $BATCHLOAD          $batcon)
  543. ;(DEF%TR $BATCON $batcon)
  544. (DEF%TR $CLOSEFILE $batcon)
  545. (DEF%TR $COMPFILE           $batcon)
  546. (DEF%TR $DELFILE $batcon)
  547. (DEF%TR $DEMO $batcon)
  548. (DEF%TR $DEPENDENCIES $batcon)
  549. (DEF%TR $DESCRIBE           $batcon)
  550. (DEF%TR $DISKFREE $batcon)
  551. (DEF%TR $DISKUSE $batcon)
  552. (DEF%TR $DISPFUN $batcon)
  553. (DEF%TR $DISPRULE $batcon)
  554. (DEF%TR $FILELENGTH $batcon)
  555. (DEF%TR $FILELIST $batcon)
  556. (DEF%TR $FUNDEF $batcon)
  557. (DEF%TR $FULLDISKUSE $batcon)
  558. (DEF%TR $GRADEF $batcon)
  559. (DEF%TR $LISTFILES $batcon)
  560. (DEF%TR $LOADFILE $batcon)
  561. (DEF%TR $LOADARRAYS         $batcon)
  562. (DEF%TR $LOADPLOTS $batcon)
  563. (DEF%TR $MAKEATOMIC $batcon)
  564. (DEF%TR $NAMEFILE $batcon)
  565. (DEF%TR $NUMERVAL           $batcon)
  566. (DEF%TR $OPTIONS $batcon)
  567. (DEF%TR $ORDERGREAT $batcon)
  568. (DEF%TR $ORDERLESS $batcon)
  569. (DEF%TR $PLOTMODE $batcon)
  570. (DEF%TR $PRIMER $batcon)
  571. (DEF%TR $PRINTDISKUSE $batcon)
  572. (DEF%TR $PRINTFILE $batcon)
  573. (DEF%TR $PRINTPROPS $batcon)
  574. (DEF%TR $PROPERTIES $batcon)
  575. (DEF%TR $PROPVARS $batcon)
  576. (DEF%TR $QLISTFILES $batcon)
  577. (DEF%TR $REMFILE            $batcon)
  578. (DEF%TR $REMFUNCTION $batcon)
  579. (DEF%TR $REMOVE $batcon)
  580. (DEF%TR $REMVALUE           $batcon)
  581. (DEF%TR $RENAMEFILE $batcon)
  582. (DEF%TR $RESTORE $batcon)
  583. (DEF%TR $TRANSLATE          $batcon)
  584. (DEF%TR $WRITEFILE $batcon)
  585. (DEF%TR $HARDCOPY $batcon)
  586. (DEF%TR $LABELS $batcon)
  587. (DEF%TR $SETUP_AUTOLOAD $batcon)
  588. (DEF%TR $TOBREAK $batcon  )
  589.  
  590.  
  591. ;; Local Modes:
  592. ;; Mode: LISP
  593. ;; Comment Col: 40
  594. ;; END:
  595.  
  596.